;; $Id: dendrogram.lsp,v 1.2 2000/04/17 08:35:22 uluru Exp 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;
;;  Dendro proto : Dendrogram
;;
;;  This file contains code to define Dendrogram 
;;  Written by Forrest Young and Chad Petty
;;  
;;  Uses code written by Huh, Moon Yul and Lee Kyungmi, 
;;  Department of Statistics Sungkyunkwan University, 1995-1997
;;
;;  Uses AgNes: Agglomerative Nesting (Hierachical Clustering)
;;  written by Jan de Leeuw
;;
;;  12/1999 Modified by Chad Petty    (ctp) for ViSta 5 plugin
;;  04/2000 Modified by Forrest Young (fwy) for ViSta 6 plugin
;;                                          (i.e., containers)
;;
;;  dendrogram-analysis rewritten for ViSta by CTP and FWY
;;  original :dendrogram method was split up by CTP into two methods
;;    1) the dendrogram-compute method computes 'agnes', which
;;       returns a cluster list
;;    2) the dendrogram-visualization method takes a cluster list, 
;;       draws a dendrogram
;;  CTP's dendro-proto object was split into two objects by FWY
;;    1) dendro-analysis-object is used by ViSta analysis
;;       and no longer involves a graphical object.
;;       This object is created by dendrogram-analysis, 
;;       using dendrogram-compute and agnes
;;    2) dendro-visualization-object is used by ViSta visualization
;;       with the graphical object inside appropriate container.
;;       This object is created by dendrogram-visualization
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun dendrogram (data &key (linkage "simple") (proximity "Euclidean")
                        labels (draw nil) (log nil))
  (let ((cluster-model 
         (cluster-model data :linkage linkage :proximity proximity)))
    (dendrogram cluster-model 
                &key (title "Cluster Dendrogram") 
                :linkage linkage :proximity proximity
                :labels labels :draw draw :log log)))


(defun cluster-model (data &key (linkage "single") (proximity "Euclidean")
                           (iteration-plot nil))
  (send dendro-analysis-proto :new data linkage proximity iteration-plot))



(defproto dendro-analysis-proto
  '(data prxmat linkage dendro-list clusterlist dendro-seq proximity distance iterplot)
  )

(defmeth dendro-analysis-proto :isnew (data linkage proximity iterplot)
  (send self :data data)
  (send self :linkage linkage)
  (send self :proximity proximity)
  (send self :iterplot iterplot)
  (send self :clusterlist (send self :dendrogram-compute))
  self)

(defmeth dendro-analysis-proto :data (&optional new)
  (if new (setf (slot-value 'data) new))
  (slot-value 'data))

(defmeth dendro-analysis-proto :prxmat (&optional new)
  "Proximity matrix"
  (if new (setf (slot-value 'prxmat) new)) 
  (slot-value 'prxmat))

(defmeth dendro-analysis-proto :linkage (&optional new);        nil
  (if new (setf (slot-value 'linkage) new)) 
  (slot-value 'linkage))

(defmeth dendro-analysis-proto :dendro-list (&optional new);        nil
  (if new (setf (slot-value 'dendro-list) new))
  (slot-value 'dendro-list))


(defmeth dendro-analysis-proto :iterplot (&optional new);        nil
  (if new (setf (slot-value 'iterplot) new)) 
  (slot-value 'iterplot))

(defmeth dendro-analysis-proto :distance (&optional new);        nil
  (if new (setf (slot-value 'distance) new))
  (slot-value 'distance))

(defmeth dendro-analysis-proto :dendro-seq (&optional new);        nil
  (if new (setf (slot-value 'dendro-seq) new))
  (slot-value 'dendro-seq))

(defmeth dendro-analysis-proto :clusterlist (&optional new)
  (if new (setf (slot-value 'clusterlist) new))
  (slot-value 'clusterlist))

(defmeth dendro-analysis-proto :proximity (&optional type)
  (if type
      (let* ((data (send self :data))
             (prxmat 
              (cond
                ((string-equal type "Euclidean")
                 (send self :euclidean-matrix data))
                ((string-equal type "Std-euclidean")
                 (send self :standardized-euclidean-matrix data))
                ((string-equal type "Sq-euclidean")
                 (send self :squared-euclidean-matrix data))
                ((string-equal type "Cityblock")
                 (send self :cityblock-matrix data))
                ((string-equal type "Mahalanobis")
                 (send self :mahalanobis-matrix data))
                ((string-equal type "Cosine")
                 (send self :cosine-matrix data))
                ((string-equal type "Correlation")
                 (send self :correlation-matrix data)))))
        (send self :prxmat prxmat)
        (setf (slot-value 'proximity) type)))
  (slot-value 'proximity))

(defmeth dendro-analysis-proto :dendrogram-compute ()
  (send self :agnes (send self :prxmat) :type (send self :linkage)))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;   Agglomerative nesting (Hierachical Clustering)
;;   written by Jan de Leeuw
;;   Modified some function : agnes()
;;   Added function : merge-clusters-dist()
;;   Date: August 30 1995
;;
;;   File name: Clus-fn1.lsp
;;   Update: November 3, 1997 (:gap keyword argument)
;;           Feb. 17, 1998
;;   Changed from functions to methods by FWY April 20 2000
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmeth dendro-analysis-proto :agnes (diss &key (type "average"))
  (let* ((n (array-dimension diss 0))
         (k (iseq n))
         (d (copy-array diss))
         (l (list 0))
         (h (list k))
         (len 0.0))

    (loop
     (if (= 1 (array-dimension d 1)) 
         (return (list h))
         (progn 
          (multiple-value-setq (i j m) (send self :minimum-distance d))
          (setf d (send self :merge-distances   d k i j type))
          (setf k (send self :merge-clusters-dist k i j m))
          (setf l (append l (list m)))
          (setf h (append h (list k)))

          )))))

(defmeth dendro-analysis-proto :minimum-distance (x)
"Args: x
Finds the smallest element of a distance matrix,
and the corresponding indices."
  (let* ((n (array-dimension x 0))
         (r (rest (iseq n)))
         (m positive-infinity)
         im jm)
    (dolist (i r)
            (dotimes (j i)
                     (let ((a (aref x i j)))
                       (if (< a m)
                           (setf im i jm j m a)))))
    (values im jm m)))


(defmeth dendro-analysis-proto :merge-clusters-dist (l i j m)
  (let* ((n (length l))
         (v (delete i (delete j (iseq n)))))
    (append (list (list (elt l j) (elt l i) m))
            (select l v))))

(defmeth dendro-analysis-proto :merge-clusters (l i j)
  (let* ((n (length l))
         (v (delete i (delete j (iseq n)))))
    (append (list (list (elt l j) (elt l i)))
            (select l v))))

(defmeth dendro-analysis-proto :merge-distances (d l i j type)
  (if (= 2 (array-dimension d 0)) #2A((0))
      (let* ((n (array-dimension d 0))
             (e (make-array (list (1- n) (1- n))
                            :initial-element 0))
             (k (1+ (iseq (- n 2))))
             (nn (iseq n))
             (v (delete i (delete j (iseq n))))
             (na (length (combine (elt l i))))
             (nb (length (combine (elt l j))))
             (da (select (select d i nn) 0 v))
             (db (select (select d j nn) 0 v))
             (sl (mapcar #'list (select l v)))
             (qa (make-array (list 1 (- n 2))
                             :initial-contents 
                             (mapcar #'length sl)))
             (dc (aref d i j))
             (av (send self :merge-methods da db dc na nb qa type)))
        (setf (select e k k) (select d v v))
        (setf (select e 0 k) av)
        (setf (select e k 0) (transpose av))
        e)))

(defmeth dendro-analysis-proto :merge-methods (x y z nx ny nq type)
  (let ((nt (+ nx ny)))
    (cond
      ((string-equal type "centroid")
       (sqrt (- (+ (* (/ nx nt) x x)
                   (* (/ ny nt) y y))
                (/ (* nx ny z z) (* nt nt)))))
      ((string-equal type "ward")
       (sqrt (- (+ (* (/ (+ nx nq) (+ nt nq)) x x)
                   (* (/ (+ ny nq) (+ nt nq)) y y))
                (/ (* (/ nq (+ nt nq)) z z)))))
      ((string-equal type "gower")
       (sqrt (- (+ (/ (* x x) 2)
                   (/ (* y y) 2))
                (/ (* z z) 4))))
      ((string-equal type "weighted")
       (/ (+ x y) 2))                     
      ((string-equal type "single")
       (pmin x y))
      ((string-equal type "complete")
       (pmax x y))
      (t
       (+ (* (/ nx nt) x)
          (* (/ ny nt) y))))))


(defmeth dendro-analysis-proto :euclidean ()
  (let* ((data (send self :data))
         (disim-mat (send self :euclidean-matrix data)))
    (send self :prxmat disim-mat)))

(defmeth dendro-analysis-proto :std-euclidean ()
  (let* ((data (send self :data))
         (disim-mat (send self :standardized-euclidean-matrix data)))
    (send self :prxmat disim-mat)))

(defmeth dendro-analysis-proto :mahalanobis ()
  (let* ((data (send self :data))
         (disim-mat (send self :mahalanobis-matrix data)))
    (send self :prxmat disim-mat)))

(defmeth dendro-analysis-proto :cityblock ()
  (let* ((data (send self :data))
         (disim-mat (send self :cityblock-matrix data)))
    (send self :prxmat disim-mat)))

(defmeth dendro-analysis-proto :cosine ()
  (let* ((data (send self :data))
         (sim-mat (send self :cosine-matrix data)))
    (send self :prxmat sim-mat)))

(defmeth dendro-analysis-proto :correlation ()
  (let* ((data (send self :data))
         (sim-mat (send self :correlation-matrix data)))
    (send self :prxmat sim-mat)))

(defmeth dendro-analysis-proto :squared-euclidean-matrix (x)
  "Arg(x) : list type
   Returns the Squared Euclidean distance matrix for the rows"
  (let* ((m (length x))
         (mat (make-array (list m m))))
    (dotimes (i m mat)
             (let ((xi (select x i)))
               (dotimes (j (1+ i))
                        (let* ((xij (- xi (select x j)))
                               (val (inner-product xij xij)))
                          (setf (aref mat i j) val)
                          (setf (aref mat j i) val)))))))


(defmeth dendro-analysis-proto :euclidean-matrix (x)
  "Arg(x) : list type
   Returns the Euclidean distance matrix for the rows"
  (let* ((m (length x))
         (mat (make-array (list m m) :initial-element 0 )))
    (dotimes (i m)
             (let ((xi (select x i)))
               (dotimes (j (1+ i))
                        (let* ((xij (- xi (select x j)))
                               (val
                                (sqrt (inner-product xij xij))))
                          (setf (aref mat i j) val)))))
    (+ mat (transpose mat))))

(defmeth dendro-analysis-proto :standardized-euclidean-matrix (x)
  "Arg(x) : list type
   Returns the Standardized Euclidean distance matrix for the rows"
  (let* ((m (length x))
         (tx (transpose x))
         (mat (make-array (list m m)))
         (std '())
         (res '()))
    (dolist (xi tx)
            (setf std (cons (standard-deviation xi) std)))
    (dotimes (i m mat)
             (let ((xi (select x i)))
               (dotimes (j (1+ i))
                    (let* ((xj (select x j))
                           (xij (/ (- xi xj) std))
                           (val (sqrt (inner-product xij xij))))
                      (setf (aref mat i j) val)
                      (setf (aref mat j i) val)))))))


(defmeth dendro-analysis-proto :mahalanobis-matrix (x)
  "Arg(x) : list type
   Returns the Mahalanobis distance matrix for the rows"

  (let* ((m (length x))
         (n (length (first x)))
         (mat (make-array (list m n) 
                          :initial-contents x))
         (cov (covariance-matrix mat))
         (inv-cov (inverse cov))
         (maha (make-array (list m m))))
    (dotimes (i m maha)
             (let ((xi (select x i)))
               (dotimes (j (1+ i))
                        (let* ((xj (select x j))
                               (d (- xi xj))
                               (dt (make-array (list n 1)
                                            :initial-contents d))
                               (val (first (matmult d cov dt))))
                          (setf (aref maha i j) val)
                          (setf (aref maha j i) val)))))))


(defmeth dendro-analysis-proto :cityblock-matrix (x)
  "Arg(x) : list type
   Returns the Manhattan or City Block matrix for the rows"
  (let* ((m (length x))
         (mat (make-array (list m m) :initial-element 0)))
    (dotimes (i m mat)
             (let ((xi (select x i)))
               (dotimes (j (1+ i))
                        (let ((val (sum (abs (- xi (select x j))))))
                          (setf (aref mat i j) val)))))
    (+ mat (transpose mat))))


(defmeth dendro-analysis-proto :cosine-matrix (x)
  "Arg(x) : list type
   Returns the Cosine matrix for the rows"
  (let* ((m (length x))
         (mat (make-array (list m m))))
    (dotimes (i m mat)
             (let* ((xi (select x i))
                    (xii (/ (sqrt (inner-product xi xi)))))
               (dotimes (j (1+ i))
                        (let* ((xj (select x j))
                               (xjj (/ (sqrt (inner-product xj xj))))
                               (val (* (inner-product xi xj) xii xjj)))
                          (setf (aref mat i j) val)
                          (setf (aref mat j i) val)))))))


(defmeth dendro-analysis-proto :correlation-matrix (x)
  "Arg(x) : list type
   Returns the Correlation matrix for the rows"
  (let* ((m (length x))
         (n (length (first x)))
         (mat (make-array (list n m) 
                          :initial-contents (transpose x)) )
         (cov (covariance-matrix mat))
         (dg (/ (sqrt (diagonal cov))))
         (cor (make-array (list m m))))
    (dotimes (i m cor)
             (let ((di (elt dg i)))
               (dotimes (j (1+ i))
                        (let* ((dj (elt dg j))
                               (val (* (aref cov i j) di dj)))
                          (setf (aref cor i j) val)
                          (setf (aref cor j i) val)))))))

(defun decision-xy (list)
  (if (atom list)
      (list list 0)
      (list (center-huh list) (third list))))


(defun make-seq (list)
  (let* ((fl (first list))
         (sl (rest list)))
    (cond 
      ((floatp fl) (list fl))
      ((integerp fl) (cons (setf seq (1+ seq)) (make-seq sl)))
      (t (cons (make-seq fl) (make-seq sl))))))


(defun dendro-seq (list)
  (setf seq 0)
  (make-seq list))

;changed name of following function to avoid conflict with 
;ViSta function of same name which centers a variable at the mean
;forrest young 2000-04-13

(defun center-huh (list)
  (let* ((f-list (first list))
         (s-list (second list)))
    (mean (LIST 
           (if (final? f-list) (loc f-list) (center-huh f-list))
           (if (final? s-list) (loc s-list) (center-huh s-list))))))


(defun loc (list)
  (if (atom list) list
      (let ((sel (select list (iseq (- (length list) 1)))))
        (mean sel))))


(defun final? (list)
  (cond 
    ((atom list) t)
    ((= (length (combine list)) (length list))  t)
    (t nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun dendrogram-vis (cluster-model 
                       &key (title "Cluster Dendrogram") 
                       (linkage "single") (proximity "Euclidean")
                       (labels nil) (draw nil) (log nil))
  (let* ((dend (send dendro-visualization-proto :new
                    cluster-model title linkage proximity labels draw log)))
          dend))

(defproto dendro-visualization-proto 
  '(cluster-model prxmat linkage dendro-list symbol proximity
         distance label dendro-seq draw-label? log-scale? scale clusterlist)
  nil graph-proto)

(defmeth dendro-visualization-proto :isnew 
  (cluster-model title linkage proximity labels draw log)
  (call-next-method 2)
  (let* ((cl (caar (last (first (send cluster-model :clusterlist)))))
       	 (l (dendro-seq cl))
         (n (length (send cluster-model :data))))
    (send self :labels 
          (if labels labels
              (mapcar #'(lambda (i) (format nil "~a" i)) (iseq 1 n))))
    (send self :clusterlist cl)
    (send self :cluster-model cluster-model)
    (send self :title title)
    (send self :linkage linkage)
    (send self :proximity proximity)
    (send self :draw-label? draw)
    (send self :log-scale? log)
    (send self :show-window)
    (send self :dendro-seq l)
    (send self :dendro-list cl)
    (send self :set-distance&symbol)
    (send self :set-margin)
    (send self :draw-label? t)
    (send self :draw-dendro-label)
    (send self :draw-dendro-lines l :log log)
    ;(let ((m (send self :set-margin)))
     ; (send self :margin (first m) (second m) (third m) (nth 3 m)))
    (APPLY #'SEND SELF :MARGIN (SEND SELF :SET-MARGIN))
    )
  )

(defmeth dendro-visualization-proto :cluster-model (&optional new)
  (if new (setf (slot-value 'cluster-model) new))
  (slot-value 'cluster-model))

(defmeth dendro-visualization-proto :prxmat (&optional new)
  "Proximity matrix"
  (if new (setf (slot-value 'prxmat) new)) 
  (slot-value 'prxmat))

(defmeth dendro-visualization-proto :proximity (&optional new)
  (if new (setf (slot-value 'proximity) new)) 
  (slot-value 'proximity))

(defmeth dendro-visualization-proto :linkage (&optional new)
  (if new (setf (slot-value 'linkage) new)) 
  (slot-value 'linkage))

(defmeth dendro-visualization-proto :labels (&optional new)
  (if new (setf (slot-value 'label) new))
  (slot-value 'label))

(defmeth dendro-visualization-proto :distance (&optional new)
  (if new (setf (slot-value 'distance) new))
  (slot-value 'distance))

(defmeth dendro-visualization-proto :draw-label? (&optional new)
  (if new (setf (slot-value 'draw-label?) new))
  (slot-value 'draw-label?))

(defmeth dendro-visualization-proto :log-scale? (&optional new)
  (if new (setf (slot-value 'log-scale?) new))
  (slot-value 'log-scale?))

(defmeth dendro-visualization-proto :dendro-seq (&optional new)
  (if new (setf (slot-value 'dendro-seq) new))
  (slot-value 'dendro-seq))

(defmeth dendro-visualization-proto :dendro-list (&optional new)
  (if new (setf (slot-value 'dendro-list) new))
  (slot-value 'dendro-list))

(defmeth dendro-visualization-proto :clusterlist (&optional new)
  (if new (setf (slot-value 'clusterlist) new))
  (slot-value 'clusterlist))

(defmeth dendro-visualization-proto :linkage (&optional new)
"Linkage method"
  (if new (setf (slot-value 'linkage) new)) 
  (slot-value 'linkage))

(defmeth dendro-visualization-proto :dendro-list (&optional new)
  (if new (setf (slot-value 'dendro-list) new))
  (slot-value 'dendro-list))

(defmeth dendro-visualization-proto :distance (&optional new)
  (if new (setf (slot-value 'distance) new))
  (slot-value 'distance))

(defmeth dendro-visualization-proto :dendro-seq (&optional new)
  (if new (setf (slot-value 'dendro-seq) new))
  (slot-value 'dendro-seq))

(defmeth dendro-visualization-proto :clusterlist (&optional new)
  (if new (setf (slot-value 'clusterlist) new))
  (slot-value 'clusterlist))

(defmeth dendro-visualization-proto :labels (&optional new)
  (if new (setf (slot-value 'label) new))
  (slot-value 'label))

(defmeth dendro-visualization-proto :draw-label? (&optional new)
  (if new (setf (slot-value 'draw-label?) new))
  (slot-value 'draw-label?))

(defmeth dendro-visualization-proto :log-scale? (&optional new)
  (if new (setf (slot-value 'log-scale?) new))
  (slot-value 'log-scale?))

(defmeth dendro-visualization-proto :text ()
  (let ((tw (send self :text-width "1"))
        (ta (send self :text-ascent))
        (td (send self :text-descent)))
    (list tw ta td)))

(defmeth dendro-visualization-proto :symbol (cluster)
  (let* ((labels (send self :labels))
         (sym (mapcar #'(lambda (i)
                          (select labels i))
                      cluster)))
    (send self :slot-value 'symbol sym)))

(defmeth dendro-visualization-proto :set-distance&symbol ()
  (let* ((dlist (send self :dendro-list))
         (c (combine dlist))
         (ip (mapcar #'integerp c))
         (cl (select c (which ip)))
         (fp (mapcar #'floatp c))
         (dis (select c (which fp)))
         (min-dis (min dis))
         (max-dis (max dis))
         (mdis (round max-dis))
         (n (length cl))
         (min (round (/ mdis 4))))
    (send self :distance (list min-dis max-dis))
    (send self :symbol cl)))

(defmeth dendro-visualization-proto :set-margin ()
  (let* ((text (send self :text))
         (ta (second text))
         (th (+ (send self :text-ascent) (send self :text-descent)))
         (dis (send self :distance))
         (max-dis (second dis))
         (max-wd (send self :text-width (format nil "~,2f" max-dis)))
         (max-label-length (max (mapcar #'(lambda (label) 
                                           (length label))
                                       (send self :labels))))
         (nchar 8)
         (left (+ max-wd (* 3 ta)))
         (right (floor (* th 1.5)))
         (top (floor (* th 2.5)))

         (bottom (max (floor (* th 2.5)) 
                      (floor (+ (* th .5) 
                                (* th (- (min nchar max-label-length) 1))))))
         )
    (list left top right bottom)))

(defmeth dendro-visualization-proto :set-range ()
  (let* ((dis (send self :distance))
         (log (send self :log-scale?))
         (min (first dis))
         (epsilon (if (> min 1)
                      (* (log min) 0.6)
                     (* min 0.6)))
         (min (if log epsilon 0))
         (max (if log (log (second dis)) (second dis)))
         (n (length (send self :labels))))
    (send self :range 0 0 (1+ n) :draw nil)
    (send self :range 1 epsilon  max :draw nil)));PV was 0


(defmeth dendro-visualization-proto :draw-dendro-axis ()
  (let* ((dis (send self :distance))
         (log (send self :log-scale?))
         (min (first dis))
         (max (second dis))
         (m (/ (- max min) 2))
         (n (length (send self :labels)))
         (text (send self :text))
         (ta (first text))
         (epsilon (if (> min 1)
                      (* (log min) 0.6)
                      (* min 0.6)))
         (low-loc (if log 
                      (send self :scaled-to-canvas 0 epsilon)
                      (send self :scaled-to-canvas 0 0)))
         (min-loc (if log 
                      (send self :scaled-to-canvas 0 (log min))
                      (send self :scaled-to-canvas 0 min)))
         (m-loc (if log
                    (send self :scaled-to-canvas 0 (log m))
                    (send self :scaled-to-canvas 0 m)))
         (high-loc (if log
                       (send self :scaled-to-canvas 0 (log max))
                       (send self :scaled-to-canvas 0 max)))
         (x (first low-loc))
         (rt-x (first (send self :scaled-to-canvas n 1)))
         (bt-y (second low-loc))
         (min-y (second min-loc))
         (m-y (second m-loc))
         (top-y (second high-loc))
         (y (list bt-y min-y m-y top-y))
         (y-label (mapcar #'(lambda (i) (format nil "~,2f" i))
                              (list 0 min (+ min m) max))))
    (if log (send self :draw-text "(Scale = log)" 10 10 0 1))
    (send self :draw-line x bt-y x top-y)
    (send self :draw-line x bt-y rt-x bt-y)
    (dotimes (i 4)
             (let ((yi (nth i y))
                   (label (nth i y-label)))
               (send self :draw-line (- x 2) yi (+ x 2) yi)
               (send self :draw-text label (- x ta) (+ yi 8) 2 0)))))

(defmeth dendro-visualization-proto :draw-sym ()
  (let* ((symbol (slot-value 'symbol))
         (n (length symbol))
         (text (send self :text))
         (tw (first text))
         (ta (second text))
         (td (third text))
         (tad (+ ta td))
         (tx (floor (* tw .5)))
         (prevcolor (send self :draw-color))
         )
    (dotimes (i n)
             (let* ((loc (send self :scaled-to-canvas (1+ i) 0))
                    (x (- (first loc) tx))
                    (y (+ (second loc) (* tad 1)))
                    (isym (nth i symbol))
                    (tl (length isym)))
               (when (not (send self :point-color i)) (send self :point-color i 'blue))
               (send self :draw-color (send self :point-color i))
               (when (> (length isym) 14) (setf isym (select isym (iseq 14))))
               (send self :draw-text-up isym (+ 8 x) (- y 10) 2 0)
              #| (dotimes (j (min 8 tl))
                        (send self :draw-string (string (elt isym j))
                              x (+ y (* ta  j))))|#
             ))
    (send self :draw-color prevcolor)))

(defmeth dendro-visualization-proto :draw-dendro-lines (list &key (log nil))
  (let* ((left (first list))
         (right (second list))
         (prx-value (third list))
         (left_xy (decision-xy left))
         (right_xy (decision-xy right))
         (x_left (first left_xy))
         (x_right (first right_xy))
         (y_top prx-value)
         (y_left (second left_xy))
         (y_right (second right_xy))
         (x (list x_left x_left x_right x_right))
         (y (mylog (list y_left y_top y_top y_right) :log log))
         (xy (list x y)))
    (send self :add-lines xy :color 'black :draw nil)
    (if (atom left)
        (if (not (atom right))
            (send self :draw-dendro-lines right :log log))
        (if (atom right)
            (send self :draw-dendro-lines left :log log)
            (progn ()
                   (send self :draw-dendro-lines left :log log )
                   (send self :draw-dendro-lines right :log log ))))))

(defun mylog (y &key log)
  (mapcar #'(lambda (x) 
              (if log (log (if (zerop x) 0.00001  x)) x))
          y))

(defmeth dendro-visualization-proto :draw-dendro-label ()
    (send self :set-range)
    (if (send self :draw-label?)
        (send self :draw-sym))
    (send self :draw-dendro-axis))

(defmeth dendro-visualization-proto :draw-select-symbol (location symbol)
  (let* ((text (send self :text))
         (tw (first text))
         (ta (second text))
         (td (third text))
         (tad (+ ta td))
         (tx (floor (* tw .5))))
    (mapcar #'(lambda (i isym)
             (let* ((loc (send self :scaled-to-canvas (1+ i) 0))
                    (x (- (first loc) tx))
                    (y (+ (second loc) (* tad 2)))
                    (tl (length isym)))
               (dotimes (j tl)
                        (send self :draw-string (string (elt isym j))
                              x (+ y (* ta j))))))
            location symbol)))


(defmeth dendro-visualization-proto :trans-scale ()
  (let ((log (send self :log-scale?))
        (l (send self :dendro-seq)))
    (if log
        (setf (slot-value 'log-scale?) nil)
        (setf (slot-value 'log-scale?) t))
    (send self :start-buffering)
    (send self :clear :draw nil)
    (send self :draw-dendro-label)
    (send self :draw-dendro-lines l :log (send self :log-scale?))
    (send self :adjust-to-data)
    (send self :buffer-to-screen)))

(defmeth dendro-visualization-proto :show-labels ()
  (setf name-p (send label-name-list-proto :new 0))
  (send name-p :title "Observations")
  (send name-p :add-points (length (send self :labels)) 
        :point-labels (send self :labels))
  (send name-p :location 400 24))

(defmeth dendro-visualization-proto :margin (&optional l top r b)
  (if (and l top r b) (apply #'call-next-method (send self :set-margin))
      (call-next-method)))
  

(defmeth dendro-visualization-proto :redraw ()
  (when (send self :distance)
        (call-next-method)
        (if (send self :draw-label?)
            (send self :draw-sym))
        (send self :draw-dendro-axis)))

